HyperLib 1997 Winter - Disc 1/HYPERLIB-1997-Winter-CD1.ISO.7z/HYPERLIB-1997-Winter-CD1.ISO/オンラインウェア/PRG/PowerLisp 2.01 FAT Folder.sit/PowerLisp 2.01 FAT Folder/PowerLisp 2.01 ƒ/Library/assembler_68k.lisp

Lisp/Scheme | 1996-05-17 | 26KB | 868 lines

;;;
;;;        PowerLisp 2.0
;;;        Copyright ｩ 1996 Roger Corman.  All rights reserved.
;;;        68k Assembler source
;;;

;
;    Source code for assembler.
;

;
;    We do an eval-when on the entire file so that we get the
;    performance benefits immediately
;
(eval-when (:compile-toplevel :load-toplevel :execute)
    (provide :assembler)
    (in-package :assembler))

(eval-when (:compile-toplevel :load-toplevel :execute)
(export
'(
     a0  a1  a2  a3  a4  a5  a6  a7
    -a0 -a1 -a2 -a3 -a4 -a5 -a6 -a7
     a0+ a1+ a2+ a3+ a4+ a5+ a6+ a7+
     d0  d1  d2  d3  d4  d5  d6  d7
    d-registers
    a-registers
    a-inc-registers
    a-dec-registers
    $CAR
    $CDR
    $SETCAR
    $SETCDR
    $SYMBOL-VALUE
    $SYMBOL-PLIST
    $NODE-TYPE
    $CONSP
    $INTEGER
    $RETURN
    $FUNC-BEGIN
    $IF
    $IFELSE
    $REFERENCE
    link
    unlk
    rts
    dc.w
    dc.l
    moveq
    move.l
    move.b
    move.w
    movea.l
    add.l
    addi.l
    and.l
    andi.l
    or.l
    ori.l
    eor.l
    eori.l
    sub.l
    cmp.l
    tst.l
    subi.l
    clr.l
    lea
    jsr
    bra
    bsr
    bhi
    bls
    bcc
    bcs
    bne
    beq
    bvc
    bvs
    bpl
    bmi
    bge
    blt
    bgt
    ble
    movem.l
)))

(defconstant a0 0)
(defconstant a1 1)
(defconstant a2 2)
(defconstant a3 3)
(defconstant a4 4)
(defconstant a5 5)
(defconstant a6 6)
(defconstant a7 7)

(defconstant a0+ 0)
(defconstant a1+ 1)
(defconstant a2+ 2)
(defconstant a3+ 3)
(defconstant a4+ 4)
(defconstant a5+ 5)
(defconstant a6+ 6)
(defconstant a7+ 7)

(defconstant -a0 0)
(defconstant -a1 1)
(defconstant -a2 2)
(defconstant -a3 3)
(defconstant -a4 4)
(defconstant -a5 5)
(defconstant -a6 6)
(defconstant -a7 7)

(defconstant d0 0)
(defconstant d1 1)
(defconstant d2 2)
(defconstant d3 3)
(defconstant d4 4)
(defconstant d5 5)
(defconstant d6 6)
(defconstant d7 7)

(defconstant d-registers '(d0 d1 d2 d3 d4 d5 d6 d7))
(defconstant a-registers '(a0 a1 a2 a3 a4 a5 a6 a7))
(defconstant a-inc-registers '(a0+ a1+ a2+ a3+ a4+ a5+ a6+ a7+))
(defconstant a-dec-registers '(-a0 -a1 -a2 -a3 -a4 -a5 -a6 -a7))

;;    Macros to access SYMBOL and NODE fields.
;;    These are dependent on the symbol class definition.
;;    The C++ source is in LispObjects.h.

(defconstant *symbol-value-offset*                 8)
(defconstant *symbol-plist-offset*                 12)
(defconstant *symbol-package-offset*             16)
(defconstant *symbol-name-offset*                 20)
(defconstant *symbol-flags-offset*                 24)
(defconstant *symbol-jump-table-entry-offset*     26)
(defconstant *symbol-jump-address-offset*         28)
(defconstant *symbol-function-offset*             32)

(defconstant *node-car-offset*                    0)
(defconstant *node-cdr-offset*                    4)
(defconstant *node-flags-offset*                8)
(defconstant *node-type-offset*                    9)

(defconstant *node-integer-offset*                0)    ;; occupies the car field

(defvar *assembler-address*    0)
(defvar *assembler-local-address*    0)    ;; keep track of offset within instruction
(defvar *assembler-references*    nil)

;
;    We do an eval-when on the entire file so that we get the
;    performance benefits immediately
;
(eval-when (:compile-toplevel :load-toplevel :execute)

(defmacro $CAR (areg &optional dest-reg)
    (unless dest-reg (setq dest-reg areg))
    `(
        (move.l (,areg ,*node-car-offset*) ,dest-reg)
     ))

(defmacro $CDR (areg &optional dest-reg)
    (unless dest-reg (setq dest-reg areg))
    `(
        (move.l (,areg ,*node-cdr-offset*) ,dest-reg)
     ))

(defmacro $SETCAR (areg value)
    `(
        (move.l ,value (,areg ,*node-car-offset*))
     ))

(defmacro $SETCDR (areg value)
    `(
        (move.l ,value (,areg ,*node-cdr-offset*))
     ))

(defmacro $SYMBOL-VALUE (areg)
    `(
        (move.l (,areg) ,areg)
        (move.l (,areg ,*symbol-value-offset*) ,areg)
        (move.l (,areg) ,areg)
     ))

(defmacro $SYMBOL-PLIST (areg)
    `(
        (move.l (,areg) ,areg)
        (move.l (,areg ,*symbol-plist-offset*) ,areg)
     ))

;; Extract the type field from a node
(defmacro $NODE-TYPE (areg dest)
    `(
        (move.l (,areg ,(- *node-type-offset* 3)) ,dest)
        (andi.l #x000000ff ,dest)
    ))

(defmacro $CONSP (areg)
    `(
        ($NODE-TYPE ,areg d0)
        (cmp.l 0 d0)
    ))

(defmacro $INTEGER (areg &optional dest-reg)
    (unless dest-reg (setq dest-reg areg))
    `(
        (move.l (,areg ,*node-integer-offset*) ,dest-reg)
     ))


;;
;;    The $RETURN macro zeros out the multiple value cell, stores
;;    the passed value in d0 (to return it), and unlinks the stack frame.
;;
(defmacro $RETURN (retval)
    (if (eq retval 'a0)
        `(
            (clr.l (common-lisp::%multiple-values-address))
            (unlk a6)
            (rts)
         )
        `(
            (clr.l (common-lisp::%multiple-values-address))
            (move.l ,retval a0)
            (unlk a6)
            (rts)
         )))

;;
;;    The $FUNC-BEGIN macro sets up the A6 stack frame link,
;;    and stores a pointer to the parameter block in A0.
;;    Usage:
;;        ($FUNC-BEGIN 4)        ;; allocates 4 bytes (space for one object)
;;                            ;; on the stack
;;
(defmacro $FUNC-BEGIN (size)
    `(
        (link a6 ,size)
        (move.l (a6 8) a0)
     ))

;;
;;    $IF macro
;;    Usage:
;;        ($IF
;;            (cmp.l d3 0)         ;; if d3 == 0 the next statement will be executed
;;            (
;;                (move.l d0 d3)
;;            ))
;;
(defmacro $IF (condition instructions)
    (let ((temp-label (gensym)))
        ;;    allow single instruction clauses or lists of instructions
        (if (not (listp (car condition)))
            (setq condition (list condition)))
        (if (not (listp (car instructions)))
            (setq instructions (list instructions)))

        `(
            ,@condition
            (bne ,temp-label)
            ,@instructions
            ,temp-label
         )))

;;
;;    $IFELSE macro
;;    Usage:
;;        ($IFELSE
;;            (cmp.l d3 0)         ;; if d3 == 0 the next instruction will be executed
;;            (
;;                (move.l d0 d3)
;;            )
;;            (
;;                (move.l d2 d3)    ;; otherwise this instruction will be executed
;;            ))
;;
(defmacro $IFELSE (condition if-instructions else-instructions)
    (let ((else-label (gensym))
          (exit-label (gensym)))

        ;;    allow single instruction clauses or lists of instructions
        (if (not (listp (car condition)))
            (setq condition (list condition)))
        (if (not (listp (car if-instructions)))
            (setq if-instructions (list if-instructions)))
        (if (not (listp (car else-instructions)))
            (setq else-instructions (list else-instructions)))

        `(
            ,@condition
            (bne ,else-label)
            ,@if-instructions
            (bra ,exit-label)
            ,else-label
            ,@else-instructions
            ,exit-label
         )))

;;
;;    The $REFERENCE macro does not generate any instructions, but
;;    is used by the compiler as a flag to the assembler to correctly
;;    generate address reference entries when code is compiled to a file.
;;
(defmacro $REFERENCE (referenced-item)
    nil)

(defmacro link (areg offset) `(,(+ (symbol-value areg) #x4e50) ,offset))
(defmacro unlk (areg) `(,(+ (symbol-value areg) #x4e58)))
(defmacro rts () `(#x4e75))
(defmacro dc.w (w)
    (cond
        ((symbolp w)
         (add-reference `(%symbol-value-word ,w) -2)
         (list (symbol-value w)))
        (t (list w))))

(defmacro dc.l (w)
    (cond
        ((symbolp w)
         (add-reference `(%symbol-value ,w) -2)
         (multiple-value-list (truncate (symbol-value w) #x10000)))
        (t (multiple-value-list (truncate w #x10000)))))

(defmacro moveq (byte dreg)
    (if (or (< byte 0) (> byte 255))
        (error "Data out of range.~%Instruction: moveq  Value: ~A" byte))
    (unless (member dreg d-registers)
        (error "Invalid data register. ~%Instruction: moveq  Operand: ~A" dreg))
    (list (+ #x7000 byte (* (symbol-value dreg) #x200))))

(defmacro move.l (sreg dreg)
    (move-instruction sreg dreg 'long))

(defmacro move.b (sreg dreg)
    (move-instruction sreg dreg 'byte))

(defmacro move.w (sreg dreg)
    (move-instruction sreg dreg 'word))

(defun move-instruction (sreg dreg size)
    (let ((s (encode-address sreg size))(d (encode-address dreg size)) op-code)
        (setq op-code
            (case size
                (long #x2000)
                (byte #x1000)
                (word #x3000)))
        `(,(+ op-code
                (* (encoded-address-reg d) #x200) ; destination register bits 9-11
                (* (encoded-address-mode d) #x40) ; destination mode bits 6-8
                (* (encoded-address-mode s) #x8)  ; source mode bits 3-5
                (encoded-address-reg s))          ; source register
            ,@(encoded-address-data s)
            ,@(encoded-address-data d))))


(defmacro movea.l (sreg dreg)
    (unless (member dreg a-registers)
        (error "Invalid address register. ~%Instruction: movea.l  Operand: ~A" dreg))
    (let ((s (encode-address sreg))(d (symbol-value dreg)))
        (append
            (list (+ #x2040
                    (* d #x200)                ; destination register bits 9-11
                    (* (encoded-address-mode s) #x8) ; source mode bits 3-5
                    (encoded-address-reg s)))         ; source register
            (encoded-address-data s))))

(defmacro add.l (src dest)
    (let ((s (encode-address src))(d (encode-address dest)))
        (unless (or (= (encoded-address-mode s) 0)
                    (= (encoded-address-mode d) 0))
            (error
                "The source or destination must be a d-register. ~%Instruction: add.l  Operands: ~A, ~A" src dest))
        (if (= (encoded-address-mode s) 0)    ; if D-register is source
            `(,(+ #xD000
                (* (encoded-address-reg s) #x200)        ; source register bits 9-11
                (* 6 #x40)                                ; op-mode bits 6-8
                (* (encoded-address-mode d) #x8)        ; dest mode bits 3-5
                (encoded-address-reg d))                ; dest register
                ,@(encoded-address-data d))
                                        ; else D-register is destination
            `(,(+ #xD000
                (* (encoded-address-reg d) #x200)        ; dest register bits 9-11
                (* 2 #x40)                                ; op-mode bits 6-8
                (* (encoded-address-mode s) #x8)        ; src mode bits 3-5
                (encoded-address-reg s))                ; src register
                ,@(encoded-address-data s)))))

(defmacro addi.l (src dest)
    (incf *assembler-local-address* 4)
    (let ((s src)(d (encode-address dest)))
        (unless (integerp s)
            (error "The source must be an integer. ~%Instruction: addi.l  Operand: ~A" s))
        `(,(+ #x0680
                (* (encoded-address-mode d) #x8)    ; dest mode bits 3-5
                (encoded-address-reg d))            ; dest register
                ,@(multiple-value-list (truncate s #x10000))
                ,@(encoded-address-data d))))

(defmacro and.l (src dest)
    (let ((s (encode-address src))(d (encode-address dest)))
        (unless (or (= (encoded-address-mode s) 0)
                    (= (encoded-address-mode d) 0))
            (error
                "The source or destination must be a d-register. ~%Instruction: and.l  Operands: ~A, ~A" src dest))
        (if (or (= (encoded-address-mode s) 1)
                (= (encoded-address-mode d) 1))
            (error
                "A-register not allowed as operand. ~%Instruction: and.l  Operands: ~A, ~A" src dest))
        (if (= (encoded-address-mode s) 0); if D-register is source
            `(,(+ #xC000
                (* (encoded-address-reg s) #x200) ; source register bits 9-11
                (* 6 #x40)                        ; op-mode bits 6-8
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(encoded-address-data d))
                                        ; else D-register is destination
            `(,(+ #xC000
                (* (encoded-address-reg d) #x200); dest register bits 9-11
                (* 2 #x40)                        ; op-mode bits 6-8
                (* (encoded-address-mode s) #x8); src mode bits 3-5
                (encoded-address-reg s))        ; src register
                ,@(encoded-address-data s)))))

(defmacro andi.l (src dest)
    (incf *assembler-local-address* 4)
    (let ((s src)(d (encode-address dest)))
        (unless (integerp s)
            (error "The source must be an integer. ~%Instruction: andi.l  Operand: ~A" src))
        (if (= (encoded-address-mode d) 1)
            (error "A-register not allowed as destination. ~%Instruction: andi.l  Operand: ~A" dest))
        `(,(+ #x0280
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(multiple-value-list (truncate s #x10000))
                ,@(encoded-address-data d))))

(defmacro or.l (src dest)
    (let ((s (encode-address src))(d (encode-address dest)))
        (unless (or (= (encoded-address-mode s) 0)
                    (= (encoded-address-mode d) 0))
            (error
                "The source or destination must be a d-register. ~%Instruction: or.l  Operands: ~A, ~A" src dest))
        (if (or (= (encoded-address-mode s) 1)
                (= (encoded-address-mode d) 1))
            (error
                "A-register not allowed as operand. ~%Instruction: or.l  Operands: ~A, ~A" src dest))
        (if (= (encoded-address-mode s) 0)        ; if D-register is source
            `(,(+ #x8000
                (* (encoded-address-reg s) #x200); source register bits 9-11
                (* 6 #x40)                        ; op-mode bits 6-8
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(encoded-address-data d))
                                        ; else D-register is destination
            `(,(+ #x8000
                (* (encoded-address-reg d) #x200); dest register bits 9-11
                (* 2 #x40)                        ; op-mode bits 6-8
                (* (encoded-address-mode s) #x8); src mode bits 3-5
                (encoded-address-reg s))        ; src register
                ,@(encoded-address-data s)))))

(defmacro ori.l (src dest)
    (incf *assembler-local-address* 4)
    (let ((s src)(d (encode-address dest)))
        (unless (integerp s)
            (error "The source of 'ori' must be an integer"))
        (if (= (encoded-address-mode d) 1)
            (error "ori: destination cannot be an a-register"))
        `(,(+ #x0080
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(multiple-value-list (truncate s #x10000))
                ,@(encoded-address-data d))))

(defmacro eor.l (src dest)
    (let ((s (encode-address src))(d (encode-address dest)))
        (unless (= (encoded-address-mode s) 0)
            (error "eor: source must be a d-register"))
        (if (= (encoded-address-mode d) 1)
            (error "eor: destination cannot be an a-register"))
        `(,(+ #xB000
            (* (encoded-address-reg s) #x200); source register bits 9-11
            (* 6 #x40)                        ; op-mode bits 6-8
            (* (encoded-address-mode d) #x8); dest mode bits 3-5
            (encoded-address-reg d))        ; dest register
            ,@(encoded-address-data d))))

(defmacro eori.l (src dest)
    (incf *assembler-local-address* 4)
    (let ((s src)(d (encode-address dest)))
        (unless (integerp s)
            (error "The source of 'eori' must be an integer"))
        (if (= (encoded-address-mode d) 1)
            (error "eor.i: destination cannot be an a-register"))
        `(,(+ #x0A80
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(multiple-value-list (truncate s #x10000))
                ,@(encoded-address-data d))))

(defmacro sub.l (src dest)
    (let ((s (encode-address src))(d (encode-address dest)))
        (unless (or (= (encoded-address-mode s) 0)
                    (= (encoded-address-mode d) 0))
            (error "The source or destination of 'sub' must be a d-register"))
        (if (= (encoded-address-mode s) 0)        ; if D-register is source
            `(,(+ #x9000
                (* (encoded-address-reg s) #x200); source register bits 9-11
                (* 6 #x40)                        ; op-mode bits 6-8
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(encoded-address-data d))
                                        ; else D-register is destination
            `(,(+ #x9000
                (* (encoded-address-reg d) #x200); dest register bits 9-11
                (* 2 #x40)                        ; op-mode bits 6-8
                (* (encoded-address-mode s) #x8); src mode bits 3-5
                (encoded-address-reg s))        ; src register
                ,@(encoded-address-data s)))))

(defmacro cmp.l (src dest)
    (let ((s (encode-address src))(d (encode-address dest)))
        (unless (= (encoded-address-mode d) 0)
            (error "The destination of 'cmp' must be a d-register"))
        `(,(+ #xb000
            (* (encoded-address-reg d) #x200); dest register bits 9-11
            (* 2 #x40)                        ; op-mode bits 6-8
            (* (encoded-address-mode s) #x8); src mode bits 3-5
            (encoded-address-reg s))        ; src register
            ,@(encoded-address-data s))))

(defmacro tst.l (dest)
    (let ((d (encode-address dest)))
        `(,(+ #x4A00
                (* #x40 2)                        ; size = long
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(encoded-address-data d))))

(defmacro subi.l (src dest)
    (incf *assembler-local-address* 4)
    (let ((s src)(d (encode-address dest)))
        (unless (integerp s)
            (error "The source of 'subi' must be an integer"))
        `(,(+ #x0480
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(multiple-value-list (truncate s #x10000))
                ,@(encoded-address-data d))))

(defmacro clr.l (dest)
    (let ((d (encode-address dest)))
        `(,(+ #x4200
                (* #x40 2)                        ; size = long
                (* (encoded-address-mode d) #x8); dest mode bits 3-5
                (encoded-address-reg d))        ; dest register
                ,@(encoded-address-data d))))

(defmacro lea (src dest)
    (let ((s (encode-address src))(d (encode-address dest)))
        (unless (= (encoded-address-mode d) 1)
            (error "The destination of 'lea' must be an a-register"))
        `(,(+ #x41C0
                (* #x200 (encoded-address-reg d)); dest register bits 9-11
                (* (encoded-address-mode s) #x8); src mode bits 3-5
                (encoded-address-reg s))        ; src register
                ,@(encoded-address-data s))))

(defmacro jsr (dst)

    (if (symbolp dst)
        (progn
            (add-reference `(symbol-value ,dst))
            (setq dst (symbol-value dst))))

    (if (consp dst)
        (if (eq (car dst) 'function)
            (progn
                (add-reference dst)
                (return (cons #x4eb9
                    (multiple-value-list
                        (truncate (exec-address (cadr dst)) #x10000))))))
        ;; else
        (error "Invalid destination.~%Instruction: jsr  Destination: ~A" dst))

    (let ((d (encode-address dst)))
        (append
            (list (+ #x4e80
                    (* (encoded-address-mode d) #x8); dest mode bits 3-5
                    (encoded-address-reg d)))        ; dest register
            (encoded-address-data d))))

(defmacro bra (dest) `(#x6000 ,dest))
(defmacro bsr (dest) `(#x6100 ,dest))
(defmacro bhi (dest) `(#x6200 ,dest))
(defmacro bls (dest) `(#x6300 ,dest))
(defmacro bcc (dest) `(#x6400 ,dest))
(defmacro bcs (dest) `(#x6500 ,dest))
(defmacro bne (dest) `(#x6600 ,dest))
(defmacro beq (dest) `(#x6700 ,dest))
(defmacro bvc (dest) `(#x6800 ,dest))
(defmacro bvs (dest) `(#x6900 ,dest))
(defmacro bpl (dest) `(#x6a00 ,dest))
(defmacro bmi (dest) `(#x6b00 ,dest))
(defmacro bge (dest) `(#x6c00 ,dest))
(defmacro blt (dest) `(#x6d00 ,dest))
(defmacro bgt (dest) `(#x6e00 ,dest))
(defmacro ble (dest) `(#x6f00 ,dest))

(setf (get 'd0 'post-increment-mask) #x0001)
(setf (get 'd1 'post-increment-mask) #x0002)
(setf (get 'd2 'post-increment-mask) #x0004)
(setf (get 'd3 'post-increment-mask) #x0008)
(setf (get 'd4 'post-increment-mask) #x0010)
(setf (get 'd5 'post-increment-mask) #x0020)
(setf (get 'd6 'post-increment-mask) #x0040)
(setf (get 'd7 'post-increment-mask) #x0080)
(setf (get 'a0 'post-increment-mask) #x0100)
(setf (get 'a1 'post-increment-mask) #x0200)
(setf (get 'a2 'post-increment-mask) #x0400)
(setf (get 'a3 'post-increment-mask) #x0800)
(setf (get 'a4 'post-increment-mask) #x1000)
(setf (get 'a5 'post-increment-mask) #x2000)
(setf (get 'a6 'post-increment-mask) #x4000)
(setf (get 'a7 'post-increment-mask) #x8000)

(setf (get 'a7 'pre-decrement-mask) #x0001)
(setf (get 'a6 'pre-decrement-mask) #x0002)
(setf (get 'a5 'pre-decrement-mask) #x0004)
(setf (get 'a4 'pre-decrement-mask) #x0008)
(setf (get 'a3 'pre-decrement-mask) #x0010)
(setf (get 'a2 'pre-decrement-mask) #x0020)
(setf (get 'a1 'pre-decrement-mask) #x0040)
(setf (get 'a0 'pre-decrement-mask) #x0080)
(setf (get 'd7 'pre-decrement-mask) #x0100)
(setf (get 'd6 'pre-decrement-mask) #x0200)
(setf (get 'd5 'pre-decrement-mask) #x0400)
(setf (get 'd4 'pre-decrement-mask) #x0800)
(setf (get 'd3 'pre-decrement-mask) #x1000)
(setf (get 'd2 'pre-decrement-mask) #x2000)
(setf (get 'd1 'pre-decrement-mask) #x4000)
(setf (get 'd0 'pre-decrement-mask) #x8000)

(defmacro movem.l (&rest r)
    (incf *assembler-local-address* 2)
    (let ((instruction 0) (mask 0) (ea))
    (if (consp (car r))        ;; post-increment-mode
        (progn
            (setq ea (encode-address (car r)))
            (setq r (cdr r))
            (setq instruction
                (+ #x4cc0
                    (* (encoded-address-mode ea) 8)
                    (encoded-address-reg ea)))
            (dolist (i r) (setq mask (+ mask (get i 'post-increment-mask))))
            (return (list* instruction mask (encoded-address-data ea))))
        (progn                ;; else pre-decrement-mode
            (setq ea (encode-address (car (last r))))
            (setq instruction
                (+ #x48c0
                    (* (encoded-address-mode ea) 8)
                    (encoded-address-reg ea)))
            (dolist (i r)
                (if (symbolp i)
                    (setq mask (+ mask (get i 'pre-decrement-mask)))))
            (return (list* instruction mask (encoded-address-data ea)))))))

(defun long-words (addr) (multiple-value-list (floor addr #x10000)))

;
;    encode-address
;    Returns a list consisting of:
;        (mode reg data1 data2 data3 ...)
;    where there may be [0..n] data words (16-bit quantities)
;
(defun encode-address (addr &optional (size 'long) &aux retval)
    (cond
        ((and (consp addr) (eq (car addr) 'function))
         (let ((exec (exec-address (cadr addr))))
            (add-reference addr)
            (setq retval (list* 7 4 (long-words exec)))))

        ((and (consp addr) (eq (car addr) 'quote))
         (let ((exec (address (cadr addr))))
            (add-reference addr)
            (setq retval (list* 7 4 (long-words exec)))))

        ((and (consp addr) (eq (car addr) 'symbol-function))
         (let ((func (address (symbol-function (cadr addr)))))
            (add-reference addr)
            (setq retval (list* 7 4 (long-words func)))))

        ((symbolp addr)
         (cond
            ((member addr d-registers)
                (setq retval (list 0 (symbol-value addr))))
            ((member addr a-registers)
                (setq retval (list 1 (symbol-value addr))))
            (t
                (add-reference `(symbol-value ,addr))
                (setq addr (symbol-value addr))
                (if (eq size 'long)
                    (setq retval (list* 7 4 (long-words addr)))
                    (setq retval (list 7 4 (mod addr #x10000)))))))

        ((consp addr)
         (setq retval
            (cond
                ((member (car addr) a-registers)
                 (if (and (cdr addr) (/= (cadr addr) 0))
                     (list* 5 (symbol-value (car addr)) (cdr addr))
                    (list 2 (symbol-value (car addr)))))
                ((member (car addr) a-inc-registers)
                 (list 3 (symbol-value (car addr))))
                ((member (car addr) a-dec-registers)
                 (list 4 (symbol-value (car addr))))
                ((and (symbolp (car addr)) (null (cdr addr)))
                 (add-reference `(symbol-value ,(car addr)))
                 (list* 7 1 (long-words (symbol-value (car addr)))))
                ((and (integerp (car addr)) (null (cdr addr)))
                 (list* 7 1 (long-words (car addr))))
                (t (error "Unknown address expression: ~A" addr)))))

        ((integerp addr)
         (if (eq size 'long)
            (setq retval (list* 7 4 (long-words addr)))
            (setq retval (list 7 4 (mod addr #x10000)))))

        (t (error "Unknown address expression: ~A" addr)))

    (if (> (length retval) 2)
        (incf *assembler-local-address* (* 2 (length retval))))
    (return retval))

;;
;;    encoded-address-mode
;;    Returns the mode (integer) of the passed address structure.
;;
(defun encoded-address-mode (addr)
    (car addr))

(defun encoded-address-reg (addr)
    (cadr addr))

(defun encoded-address-data (addr)
    (cddr addr))

(defun assemble (assembler-instructions references &optional environment)
  (let*
    ((label-table (make-hash-table :test #'eql))
      (newlist nil)
      (codelist nil)
      (*assembler-address* 0)
      (*assembler-local-address* 0)
      (*assembler-references* nil)
      operator)

    (do ((n assembler-instructions (cdr n))
         statement)
        ((null n))
        (setq statement (car n))
        (cond
            ;; if it is a label, add it to the hash table
            ((symbolp statement)
             (setf (gethash statement label-table) *assembler-address*))
            ((consp statement)
             (if (integerp (car statement))     ;; skip address if there is one
                 (setq statement (cdr statement)))

             ;; make sure there is a macro definition
             (setq operator (car statement))
             (unless (symbolp operator)
                 (error "Invalid instruction: ~A" operator))
             (unless (macro-function operator)
                 (error "No definition for instruction: ~A" statement))

             ;; expand the macro one time
             (setq *assembler-local-address* 2)    ;; reset this each instruction
             (setq statement (macroexpand-1 statement))

             ;; check for multiple statement result (assembler macro expansion)
             (if (and (consp statement) (not (integerp (car statement))))
                 ;; just splice in the new instructions and continue
                (setq n (append (list nil) statement (cdr n)))
                (if (consp statement)
                    ;; This address is only correct because we are requiring
                    ;; all branch destinations to be 16-bit offsets.
                    ;; This avoids having to calculate the sizes here.
                    ;; i.e. each symbol becomes one 16-bit displacement word.
                    (progn
                        (incf *assembler-address* (* (length statement) 2))
                        (push statement newlist)))))

            ;; error if not a symbol or a list
            (t (error "Invalid label encountered: ~A" statement))))

    ;; Now go through and append all the sublists together,
    ;; resolving branch addresses as we go.
    ;; We only currently support 16-bit displacements in the branch
    ;; instructions.

    (setq newlist (reverse newlist))
    (setq *assembler-address* 0)
    (dolist (statement newlist)

        ;; check for branch instructions
        (setq operator (car statement))
        (if (= (truncate operator #x1000) 6)
            (if (and (consp (cdr statement))
                    (symbolp (cadr statement)))
                (let* ((sym (cadr statement))
                        (value (gethash sym label-table)))
                    (unless value
                        (error "Label not found: ~A" sym))
                    (unless (integerp value)
                        (error "Invalid label found.~%~ALabel: ~A Value: ~A" sym value))
                    (setf (cadr statement) (- value (+ *assembler-address* 2))))))

        (incf *assembler-address* (* 2 (length statement)))
        (dolist (n statement) (push n codelist)))

    (%build-function (reverse codelist) (nreverse *assembler-references*) environment)))

(defun add-reference (ref &optional (offset 0))
    (push
        (cons ref (+ *assembler-address* *assembler-local-address* offset))
        *assembler-references*))

)  ;; close enclosing eval-when form

;;    add defasm to the common lisp package

(eval-when (:compile-toplevel :load-toplevel :execute)
    (in-package :common-lisp)
    (export 'common-lisp::defasm))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro defasm (name lambda-list &rest forms)
;    (declare (unused lambda-list))
    (let ((doc-form nil))
        (if (and (typep (car forms) 'string)
                (cdr forms))
            (progn
                (setq doc-form
                    `((setf (documentation ',name 'function) ,(car forms))))
                (setq forms (cdr forms))))

        `(progn
            ,@doc-form
            (setf (symbol-function ',name) ,(car forms))
            (null-environment (function ,name))
            ',name)))
) ;; close eval-when